home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / dejagnu.lha / dejagnu-1.0.1 / tcl / tclVar.c < prev   
C/C++ Source or Header  |  1993-02-14  |  64KB  |  2,261 lines
  1. /* 
  2.  * tclVar.c --
  3.  *
  4.  *    This file contains routines that implement Tcl variables
  5.  *    (both scalars and arrays).
  6.  *
  7.  *    The implementation of arrays is modelled after an initial
  8.  *    implementation by Karl Lehenbauer, Mark Diekhans and
  9.  *    Peter da Silva.
  10.  *
  11.  * Copyright 1987-1991 Regents of the University of California
  12.  * Permission to use, copy, modify, and distribute this
  13.  * software and its documentation for any purpose and without
  14.  * fee is hereby granted, provided that the above copyright
  15.  * notice appear in all copies.  The University of California
  16.  * makes no representations about the suitability of this
  17.  * software for any purpose.  It is provided "as is" without
  18.  * express or implied warranty.
  19.  */
  20.  
  21. #include "tclInt.h"
  22.  
  23. /*
  24.  * The strings below are used to indicate what went wrong when a
  25.  * variable access is denied.
  26.  */
  27.  
  28. static char *noSuchVar =    "no such variable";
  29. static char *isArray =        "variable is array";
  30. static char *needArray =    "variable isn't array";
  31. static char *noSuchElement =    "no such element in array";
  32. static char *traceActive =    "trace is active on variable";
  33.  
  34. /*
  35.  * Forward references to procedures defined later in this file:
  36.  */
  37.  
  38. static  char *        CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
  39.                 Tcl_HashEntry *hPtr, char *part1, char *part2,
  40.                 int flags));
  41. static void        DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
  42. static void        DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
  43.                 Var *varPtr, int flags));
  44. static Var *        NewVar _ANSI_ARGS_((int space));
  45. static ArraySearch *    ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
  46.                 Var *varPtr, char *varName, char *string));
  47. static void        VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
  48.                 char *part1, char *part2, char *operation,
  49.                 char *reason));
  50.  
  51. /*
  52.  *----------------------------------------------------------------------
  53.  *
  54.  * Tcl_GetVar --
  55.  *
  56.  *    Return the value of a Tcl variable.
  57.  *
  58.  * Results:
  59.  *    The return value points to the current value of varName.  If
  60.  *    the variable is not defined or can't be read because of a clash
  61.  *    in array usage then a NULL pointer is returned and an error
  62.  *    message is left in interp->result if the TCL_LEAVE_ERR_MSG
  63.  *    flag is set.  Note:  the return value is only valid up until
  64.  *    the next call to Tcl_SetVar or Tcl_SetVar2;  if you depend on
  65.  *    the value lasting longer than that, then make yourself a private
  66.  *    copy.
  67.  *
  68.  * Side effects:
  69.  *    None.
  70.  *
  71.  *----------------------------------------------------------------------
  72.  */
  73.  
  74. char *
  75. Tcl_GetVar(interp, varName, flags)
  76.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  77.                  * to be looked up. */
  78.     char *varName;        /* Name of a variable in interp. */
  79.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  80.                  * or TCL_LEAVE_ERR_MSG bits. */
  81. {
  82.     register char *p;
  83.  
  84.     /*
  85.      * If varName refers to an array (it ends with a parenthesized
  86.      * element name), then handle it specially.
  87.      */
  88.  
  89.     for (p = varName; *p != '\0'; p++) {
  90.     if (*p == '(') {
  91.         char *result;
  92.         char *open = p;
  93.  
  94.         do {
  95.         p++;
  96.         } while (*p != '\0');
  97.         p--;
  98.         if (*p != ')') {
  99.         goto scalar;
  100.         }
  101.         *open = '\0';
  102.         *p = '\0';
  103.         result = Tcl_GetVar2(interp, varName, open+1, flags);
  104.         *open = '(';
  105.         *p = ')';
  106.         return result;
  107.     }
  108.     }
  109.  
  110.     scalar:
  111.     return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
  112. }
  113.  
  114. /*
  115.  *----------------------------------------------------------------------
  116.  *
  117.  * Tcl_GetVar2 --
  118.  *
  119.  *    Return the value of a Tcl variable, given a two-part name
  120.  *    consisting of array name and element within array.
  121.  *
  122.  * Results:
  123.  *    The return value points to the current value of the variable
  124.  *    given by part1 and part2.  If the specified variable doesn't
  125.  *    exist, or if there is a clash in array usage, then NULL is
  126.  *    returned and a message will be left in interp->result if the
  127.  *    TCL_LEAVE_ERR_MSG flag is set.  Note:  the return value is
  128.  *    only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
  129.  *    if you depend on the value lasting longer than that, then make
  130.  *    yourself a private copy.
  131.  *
  132.  * Side effects:
  133.  *    None.
  134.  *
  135.  *----------------------------------------------------------------------
  136.  */
  137.  
  138. char *
  139. Tcl_GetVar2(interp, part1, part2, flags)
  140.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  141.                  * to be looked up. */
  142.     char *part1;        /* Name of array (if part2 is NULL) or
  143.                  * name of variable. */
  144.     char *part2;        /* If non-null, gives name of element in
  145.                  * array. */
  146.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  147.                  * or TCL_LEAVE_ERR_MSG bits. */
  148. {
  149.     Tcl_HashEntry *hPtr;
  150.     Var *varPtr;
  151.     Interp *iPtr = (Interp *) interp;
  152.     Var *arrayPtr = NULL;
  153.  
  154.     /*
  155.      * Lookup the first name.
  156.      */
  157.  
  158.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  159.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, part1);
  160.     } else {
  161.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, part1);
  162.     }
  163.     if (hPtr == NULL) {
  164.     if (flags & TCL_LEAVE_ERR_MSG) {
  165.         VarErrMsg(interp, part1, part2, "read", noSuchVar);
  166.     }
  167.     return NULL;
  168.     }
  169.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  170.     if (varPtr->flags & VAR_UPVAR) {
  171.     hPtr = varPtr->value.upvarPtr;
  172.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  173.     }
  174.  
  175.     /*
  176.      * If this is an array reference, then remember the traces on the array
  177.      * and lookup the element within the array.
  178.      */
  179.  
  180.     if (part2 != NULL) {
  181.     if (varPtr->flags & VAR_UNDEFINED) {
  182.         if (flags & TCL_LEAVE_ERR_MSG) {
  183.         VarErrMsg(interp, part1, part2, "read", noSuchVar);
  184.         }
  185.         return NULL;
  186.     } else if (!(varPtr->flags & VAR_ARRAY)) {
  187.         if (flags & TCL_LEAVE_ERR_MSG) {
  188.         VarErrMsg(interp, part1, part2, "read", needArray);
  189.         }
  190.         return NULL;
  191.     }
  192.     arrayPtr = varPtr;
  193.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, part2);
  194.     if (hPtr == NULL) {
  195.         if (flags & TCL_LEAVE_ERR_MSG) {
  196.         VarErrMsg(interp, part1, part2, "read", noSuchElement);
  197.         }
  198.         return NULL;
  199.     }
  200.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  201.     }
  202.  
  203.     /*
  204.      * Invoke any traces that have been set for the variable.
  205.      */
  206.  
  207.     if ((varPtr->tracePtr != NULL)
  208.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  209.     char *msg;
  210.  
  211.     msg = CallTraces(iPtr, arrayPtr, hPtr, part1, part2,
  212.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
  213.     if (msg != NULL) {
  214.         VarErrMsg(interp, part1, part2, "read", msg);
  215.         return NULL;
  216.     }
  217.  
  218.     /*
  219.      * Watch out!  The variable could have gotten re-allocated to
  220.      * a larger size.  Fortunately the hash table entry will still
  221.      * be around.
  222.      */
  223.  
  224.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  225.     }
  226.     if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY)) {
  227.     if (flags & TCL_LEAVE_ERR_MSG) {
  228.         VarErrMsg(interp, part1, part2, "read", noSuchVar);
  229.     }
  230.     return NULL;
  231.     }
  232.     return varPtr->value.string;
  233. }
  234.  
  235. /*
  236.  *----------------------------------------------------------------------
  237.  *
  238.  * Tcl_SetVar --
  239.  *
  240.  *    Change the value of a variable.
  241.  *
  242.  * Results:
  243.  *    Returns a pointer to the malloc'ed string holding the new
  244.  *    value of the variable.  The caller should not modify this
  245.  *    string.  If the write operation was disallowed then NULL
  246.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  247.  *    an explanatory message will be left in interp->result.
  248.  *
  249.  * Side effects:
  250.  *    If varName is defined as a local or global variable in interp,
  251.  *    its value is changed to newValue.  If varName isn't currently
  252.  *    defined, then a new global variable by that name is created.
  253.  *
  254.  *----------------------------------------------------------------------
  255.  */
  256.  
  257. char *
  258. Tcl_SetVar(interp, varName, newValue, flags)
  259.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  260.                  * to be looked up. */
  261.     char *varName;        /* Name of a variable in interp. */
  262.     char *newValue;        /* New value for varName. */
  263.     int flags;            /* Various flags that tell how to set value:
  264.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  265.                  * TCL_LIST_ELEMENT, TCL_NO_SPACE, or
  266.                  * TCL_LEAVE_ERR_MSG. */
  267. {
  268.     register char *p;
  269.  
  270.     /*
  271.      * If varName refers to an array (it ends with a parenthesized
  272.      * element name), then handle it specially.
  273.      */
  274.  
  275.     for (p = varName; *p != '\0'; p++) {
  276.     if (*p == '(') {
  277.         char *result;
  278.         char *open = p;
  279.  
  280.         do {
  281.         p++;
  282.         } while (*p != '\0');
  283.         p--;
  284.         if (*p != ')') {
  285.         goto scalar;
  286.         }
  287.         *open = '\0';
  288.         *p = '\0';
  289.         result = Tcl_SetVar2(interp, varName, open+1, newValue, flags);
  290.         *open = '(';
  291.         *p = ')';
  292.         return result;
  293.     }
  294.     }
  295.  
  296.     scalar:
  297.     return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
  298. }
  299.  
  300. /*
  301.  *----------------------------------------------------------------------
  302.  *
  303.  * Tcl_SetVar2 --
  304.  *
  305.  *    Given a two-part variable name, which may refer either to a
  306.  *    scalar variable or an element of an array, change the value
  307.  *    of the variable.  If the named scalar or array or element
  308.  *    doesn't exist then create one.
  309.  *
  310.  * Results:
  311.  *    Returns a pointer to the malloc'ed string holding the new
  312.  *    value of the variable.  The caller should not modify this
  313.  *    string.  If the write operation was disallowed because an
  314.  *    array was expected but not found (or vice versa), then NULL
  315.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  316.  *    an explanatory message will be left in interp->result.
  317.  *
  318.  * Side effects:
  319.  *    The value of the given variable is set.  If either the array
  320.  *    or the entry didn't exist then a new one is created.
  321.  *
  322.  *----------------------------------------------------------------------
  323.  */
  324.  
  325. char *
  326. Tcl_SetVar2(interp, part1, part2, newValue, flags)
  327.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  328.                  * to be looked up. */
  329.     char *part1;        /* If part2 is NULL, this is name of scalar
  330.                  * variable.  Otherwise it is name of array. */
  331.     char *part2;        /* Name of an element within array, or NULL. */
  332.     char *newValue;        /* New value for variable. */
  333.     int flags;            /* Various flags that tell how to set value:
  334.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  335.                  * TCL_LIST_ELEMENT, and TCL_NO_SPACE, or
  336.                  * TCL_LEAVE_ERR_MSG . */
  337. {
  338.     Tcl_HashEntry *hPtr;
  339.     register Var *varPtr = NULL;
  340.                 /* Initial value only used to stop compiler
  341.                  * from complaining; not really needed. */
  342.     register Interp *iPtr = (Interp *) interp;
  343.     int length, new, listFlags;
  344.     Var *arrayPtr = NULL;
  345.  
  346.     /*
  347.      * Lookup the first name.
  348.      */
  349.  
  350.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  351.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, part1, &new);
  352.     } else {
  353.     hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
  354.         part1, &new);
  355.     }
  356.     if (!new) {
  357.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  358.     if (varPtr->flags & VAR_UPVAR) {
  359.         hPtr = varPtr->value.upvarPtr;
  360.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  361.     }
  362.     }
  363.  
  364.     /*
  365.      * If this is an array reference, then create a new array (if
  366.      * needed), remember any traces on the array, and lookup the
  367.      * element within the array.
  368.      */
  369.  
  370.     if (part2 != NULL) {
  371.     if (new) {
  372.         varPtr = NewVar(0);
  373.         Tcl_SetHashValue(hPtr, varPtr);
  374.         varPtr->flags = VAR_ARRAY;
  375.         varPtr->value.tablePtr = (Tcl_HashTable *)
  376.             ckalloc(sizeof(Tcl_HashTable));
  377.         Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  378.     } else {
  379.         if (varPtr->flags & VAR_UNDEFINED) {
  380.         varPtr->flags = VAR_ARRAY;
  381.         varPtr->value.tablePtr = (Tcl_HashTable *)
  382.             ckalloc(sizeof(Tcl_HashTable));
  383.         Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  384.         } else if (!(varPtr->flags & VAR_ARRAY)) {
  385.         if (flags & TCL_LEAVE_ERR_MSG) {
  386.             VarErrMsg(interp, part1, part2, "set", needArray);
  387.         }
  388.         return NULL;
  389.         }
  390.         arrayPtr = varPtr;
  391.     }
  392.     hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, part2, &new);
  393.     }
  394.  
  395.     /*
  396.      * Compute how many bytes will be needed for newValue (leave space
  397.      * for a separating space between list elements).
  398.      */
  399.  
  400.     if (flags & TCL_LIST_ELEMENT) {
  401.     length = Tcl_ScanElement(newValue, &listFlags) + 1;
  402.     } else {
  403.     length = strlen(newValue);
  404.     }
  405.  
  406.     /*
  407.      * If the variable doesn't exist then create a new one.  If it
  408.      * does exist then clear its current value unless this is an
  409.      * append operation.
  410.      */
  411.  
  412.     if (new) {
  413.     varPtr = NewVar(length);
  414.     Tcl_SetHashValue(hPtr, varPtr);
  415.     if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
  416.         DeleteSearches(arrayPtr);
  417.     }
  418.     } else {
  419.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  420.     if (varPtr->flags & VAR_ARRAY) {
  421.         if (flags & TCL_LEAVE_ERR_MSG) {
  422.         VarErrMsg(interp, part1, part2, "set", isArray);
  423.         }
  424.         return NULL;
  425.     }
  426.     if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) {
  427.         varPtr->valueLength = 0;
  428.     }
  429.     }
  430.  
  431.     /*
  432.      * Make sure there's enough space to hold the variable's
  433.      * new value.  If not, enlarge the variable's space.
  434.      */
  435.  
  436.     if ((length + varPtr->valueLength) >= varPtr->valueSpace) {
  437.     Var *newVarPtr;
  438.     int newSize;
  439.  
  440.     newSize = 2*varPtr->valueSpace;
  441.     if (newSize <= (length + varPtr->valueLength)) {
  442.         newSize += length;
  443.     }
  444.     newVarPtr = NewVar(newSize);
  445.     newVarPtr->valueLength = varPtr->valueLength;
  446.     newVarPtr->upvarUses = varPtr->upvarUses;
  447.     newVarPtr->tracePtr = varPtr->tracePtr;
  448.     newVarPtr->searchPtr = varPtr->searchPtr;
  449.     newVarPtr->flags = varPtr->flags;
  450.     strcpy(newVarPtr->value.string, varPtr->value.string);
  451.     Tcl_SetHashValue(hPtr, newVarPtr);
  452.     ckfree((char *) varPtr);
  453.     varPtr = newVarPtr;
  454.     }
  455.  
  456.     /*
  457.      * Append the new value to the variable, either as a list
  458.      * element or as a string.
  459.      */
  460.  
  461.     if (flags & TCL_LIST_ELEMENT) {
  462.     if ((varPtr->valueLength > 0) && !(flags & TCL_NO_SPACE)) {
  463.         varPtr->value.string[varPtr->valueLength] = ' ';
  464.         varPtr->valueLength++;
  465.     }
  466.     varPtr->valueLength += Tcl_ConvertElement(newValue,
  467.         varPtr->value.string + varPtr->valueLength, listFlags);
  468.     varPtr->value.string[varPtr->valueLength] = 0;
  469.     } else {
  470.     strcpy(varPtr->value.string + varPtr->valueLength, newValue);
  471.     varPtr->valueLength += length;
  472.     }
  473.     varPtr->flags &= ~VAR_UNDEFINED;
  474.  
  475.     /*
  476.      * Invoke any write traces for the variable.
  477.      */
  478.  
  479.     if ((varPtr->tracePtr != NULL)
  480.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  481.     char *msg;
  482.  
  483.     msg = CallTraces(iPtr, arrayPtr, hPtr, part1, part2,
  484.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES);
  485.     if (msg != NULL) {
  486.         VarErrMsg(interp, part1, part2, "set", msg);
  487.         return NULL;
  488.     }
  489.  
  490.     /*
  491.      * Watch out!  The variable could have gotten re-allocated to
  492.      * a larger size.  Fortunately the hash table entry will still
  493.      * be around.
  494.      */
  495.  
  496.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  497.     }
  498.     return varPtr->value.string;
  499. }
  500.  
  501. /*
  502.  *----------------------------------------------------------------------
  503.  *
  504.  * Tcl_UnsetVar --
  505.  *
  506.  *    Delete a variable, so that it may not be accessed anymore.
  507.  *
  508.  * Results:
  509.  *    Returns 0 if the variable was successfully deleted, -1
  510.  *    if the variable can't be unset.  In the event of an error,
  511.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  512.  *    is left in interp->result.
  513.  *
  514.  * Side effects:
  515.  *    If varName is defined as a local or global variable in interp,
  516.  *    it is deleted.
  517.  *
  518.  *----------------------------------------------------------------------
  519.  */
  520.  
  521. int
  522. Tcl_UnsetVar(interp, varName, flags)
  523.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  524.                  * to be looked up. */
  525.     char *varName;        /* Name of a variable in interp.  May be
  526.                  * either a scalar name or an array name
  527.                  * or an element in an array. */
  528.     int flags;            /* OR-ed combination of any of
  529.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  530. {
  531.     register char *p;
  532.     int result;
  533.  
  534.     /*
  535.      * Figure out whether this is an array reference, then call
  536.      * Tcl_UnsetVar2 to do all the real work.
  537.      */
  538.  
  539.     for (p = varName; *p != '\0'; p++) {
  540.     if (*p == '(') {
  541.         char *open = p;
  542.  
  543.         do {
  544.         p++;
  545.         } while (*p != '\0');
  546.         p--;
  547.         if (*p != ')') {
  548.         goto scalar;
  549.         }
  550.         *open = '\0';
  551.         *p = '\0';
  552.         result = Tcl_UnsetVar2(interp, varName, open+1, flags);
  553.         *open = '(';
  554.         *p = ')';
  555.         return result;
  556.     }
  557.     }
  558.  
  559.     scalar:
  560.     return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
  561. }
  562.  
  563. /*
  564.  *----------------------------------------------------------------------
  565.  *
  566.  * Tcl_UnsetVar2 --
  567.  *
  568.  *    Delete a variable, given a 2-part name.
  569.  *
  570.  * Results:
  571.  *    Returns 0 if the variable was successfully deleted, -1
  572.  *    if the variable can't be unset.  In the event of an error,
  573.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  574.  *    is left in interp->result.
  575.  *
  576.  * Side effects:
  577.  *    If part1 and part2 indicate a local or global variable in interp,
  578.  *    it is deleted.  If part1 is an array name and part2 is NULL, then
  579.  *    the whole array is deleted.
  580.  *
  581.  *----------------------------------------------------------------------
  582.  */
  583.  
  584. int
  585. Tcl_UnsetVar2(interp, part1, part2, flags)
  586.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  587.                  * to be looked up. */
  588.     char *part1;        /* Name of variable or array. */
  589.     char *part2;        /* Name of element within array or NULL. */
  590.     int flags;            /* OR-ed combination of any of
  591.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  592. {
  593.     Tcl_HashEntry *hPtr, dummyEntry;
  594.     Var *varPtr, dummyVar;
  595.     Interp *iPtr = (Interp *) interp;
  596.     Var *arrayPtr = NULL;
  597.  
  598.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  599.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, part1);
  600.     } else {
  601.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, part1);
  602.     }
  603.     if (hPtr == NULL) {
  604.     if (flags & TCL_LEAVE_ERR_MSG) {
  605.         VarErrMsg(interp, part1, part2, "unset", noSuchVar);
  606.     }
  607.     return -1;
  608.     }
  609.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  610.  
  611.     /*
  612.      * For global variables referenced in procedures, leave the procedure's
  613.      * reference variable in place, but unset the global variable.  Can't
  614.      * decrement the actual variable's use count, since we didn't delete
  615.      * the reference variable.
  616.      */
  617.  
  618.     if (varPtr->flags & VAR_UPVAR) {
  619.     hPtr = varPtr->value.upvarPtr;
  620.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  621.     }
  622.  
  623.     /*
  624.      * If the variable being deleted is an element of an array, then
  625.      * remember trace procedures on the overall array and find the
  626.      * element to delete.
  627.      */
  628.  
  629.     if (part2 != NULL) {
  630.     if (!(varPtr->flags & VAR_ARRAY)) {
  631.         if (flags & TCL_LEAVE_ERR_MSG) {
  632.         VarErrMsg(interp, part1, part2, "unset", needArray);
  633.         }
  634.         return -1;
  635.     }
  636.     if (varPtr->searchPtr != NULL) {
  637.         DeleteSearches(varPtr);
  638.     }
  639.     arrayPtr = varPtr;
  640.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, part2);
  641.     if (hPtr == NULL) {
  642.         if (flags & TCL_LEAVE_ERR_MSG) {
  643.         VarErrMsg(interp, part1, part2, "unset", noSuchElement);
  644.         }
  645.         return -1;
  646.     }
  647.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  648.     }
  649.  
  650.     /*
  651.      * If there is a trace active on this variable or if the variable
  652.      * is already being deleted then don't delete the variable:  it
  653.      * isn't safe, since there are procedures higher up on the stack
  654.      * that will use pointers to the variable.  Also don't delete an
  655.      * array if there are traces active on any of its elements.
  656.      */
  657.  
  658.     if (varPtr->flags &
  659.         (VAR_TRACE_ACTIVE|VAR_ELEMENT_ACTIVE)) {
  660.     if (flags & TCL_LEAVE_ERR_MSG) {
  661.         VarErrMsg(interp, part1, part2, "unset", traceActive);
  662.     }
  663.     return -1;
  664.     }
  665.  
  666.     /*
  667.      * The code below is tricky, because of the possibility that
  668.      * a trace procedure might try to access a variable being
  669.      * deleted.  To handle this situation gracefully, copy the
  670.      * contents of the variable and its hash table entry to
  671.      * dummy variables, then clean up the actual variable so that
  672.      * it's been completely deleted before the traces are called.
  673.      * Then call the traces, and finally clean up the variable's
  674.      * storage using the dummy copies.
  675.      */
  676.  
  677.     dummyVar = *varPtr;
  678.     Tcl_SetHashValue(&dummyEntry, &dummyVar);
  679.     if (varPtr->upvarUses == 0) {
  680.     Tcl_DeleteHashEntry(hPtr);
  681.     ckfree((char *) varPtr);
  682.     } else {
  683.     varPtr->flags = VAR_UNDEFINED;
  684.     varPtr->tracePtr = NULL;
  685.     }
  686.  
  687.     /*
  688.      * Call trace procedures for the variable being deleted and delete
  689.      * its traces.
  690.      */
  691.  
  692.     if ((dummyVar.tracePtr != NULL)
  693.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  694.     (void) CallTraces(iPtr, arrayPtr, &dummyEntry, part1, part2,
  695.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  696.     while (dummyVar.tracePtr != NULL) {
  697.         VarTrace *tracePtr = dummyVar.tracePtr;
  698.         dummyVar.tracePtr = tracePtr->nextPtr;
  699.         ckfree((char *) tracePtr);
  700.     }
  701.     }
  702.  
  703.     /*
  704.      * If the variable is an array, delete all of its elements.  This
  705.      * must be done after calling the traces on the array, above (that's
  706.      * the way traces are defined).
  707.      */
  708.  
  709.     if (dummyVar.flags & VAR_ARRAY) {
  710.     DeleteArray(iPtr, part1, &dummyVar,
  711.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  712.     }
  713.     if (dummyVar.flags & VAR_UNDEFINED) {
  714.     if (flags & TCL_LEAVE_ERR_MSG) {
  715.         VarErrMsg(interp, part1, part2, "unset", 
  716.             (part2 == NULL) ? noSuchVar : noSuchElement);
  717.     }
  718.     return -1;
  719.     }
  720.     return 0;
  721. }
  722.  
  723. /*
  724.  *----------------------------------------------------------------------
  725.  *
  726.  * Tcl_TraceVar --
  727.  *
  728.  *    Arrange for reads and/or writes to a variable to cause a
  729.  *    procedure to be invoked, which can monitor the operations
  730.  *    and/or change their actions.
  731.  *
  732.  * Results:
  733.  *    A standard Tcl return value.
  734.  *
  735.  * Side effects:
  736.  *    A trace is set up on the variable given by varName, such that
  737.  *    future references to the variable will be intermediated by
  738.  *    proc.  See the manual entry for complete details on the calling
  739.  *    sequence for proc.
  740.  *
  741.  *----------------------------------------------------------------------
  742.  */
  743.  
  744. int
  745. Tcl_TraceVar(interp, varName, flags, proc, clientData)
  746.     Tcl_Interp *interp;        /* Interpreter in which variable is
  747.                  * to be traced. */
  748.     char *varName;        /* Name of variable;  may end with "(index)"
  749.                  * to signify an array reference. */
  750.     int flags;            /* OR-ed collection of bits, including any
  751.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  752.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  753.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  754.                  * invoked upon varName. */
  755.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  756. {
  757.     register char *p;
  758.  
  759.     /*
  760.      * If varName refers to an array (it ends with a parenthesized
  761.      * element name), then handle it specially.
  762.      */
  763.  
  764.     for (p = varName; *p != '\0'; p++) {
  765.     if (*p == '(') {
  766.         int result;
  767.         char *open = p;
  768.  
  769.         do {
  770.         p++;
  771.         } while (*p != '\0');
  772.         p--;
  773.         if (*p != ')') {
  774.         goto scalar;
  775.         }
  776.         *open = '\0';
  777.         *p = '\0';
  778.         result = Tcl_TraceVar2(interp, varName, open+1, flags,
  779.             proc, clientData);
  780.         *open = '(';
  781.         *p = ')';
  782.         return result;
  783.     }
  784.     }
  785.  
  786.     scalar:
  787.     return Tcl_TraceVar2(interp, varName, (char *) NULL, flags,
  788.         proc, clientData);
  789. }
  790.  
  791. /*
  792.  *----------------------------------------------------------------------
  793.  *
  794.  * Tcl_TraceVar2 --
  795.  *
  796.  *    Arrange for reads and/or writes to a variable to cause a
  797.  *    procedure to be invoked, which can monitor the operations
  798.  *    and/or change their actions.
  799.  *
  800.  * Results:
  801.  *    A standard Tcl return value.
  802.  *
  803.  * Side effects:
  804.  *    A trace is set up on the variable given by part1 and part2, such
  805.  *    that future references to the variable will be intermediated by
  806.  *    proc.  See the manual entry for complete details on the calling
  807.  *    sequence for proc.
  808.  *
  809.  *----------------------------------------------------------------------
  810.  */
  811.  
  812. int
  813. Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
  814.     Tcl_Interp *interp;        /* Interpreter in which variable is
  815.                  * to be traced. */
  816.     char *part1;        /* Name of scalar variable or array. */
  817.     char *part2;        /* Name of element within array;  NULL means
  818.                  * trace applies to scalar variable or array
  819.                  * as-a-whole. */
  820.     int flags;            /* OR-ed collection of bits, including any
  821.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  822.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  823.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  824.                  * invoked upon varName. */
  825.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  826. {
  827.     Tcl_HashEntry *hPtr;
  828.     Var *varPtr = NULL;        /* Initial value only used to stop compiler
  829.                  * from complaining; not really needed. */
  830.     Interp *iPtr = (Interp *) interp;
  831.     register VarTrace *tracePtr;
  832.     int new;
  833.  
  834.     /*
  835.      * Locate the variable, making a new (undefined) one if necessary.
  836.      */
  837.  
  838.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  839.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, part1, &new);
  840.     } else {
  841.     hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, part1, &new);
  842.     }
  843.     if (!new) {
  844.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  845.     if (varPtr->flags & VAR_UPVAR) {
  846.         hPtr = varPtr->value.upvarPtr;
  847.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  848.     }
  849.     }
  850.  
  851.     /*
  852.      * If the trace is to be on an array element, make sure that the
  853.      * variable is an array variable.  If the variable doesn't exist
  854.      * then define it as an empty array.  Then find the specific
  855.      * array element.
  856.      */
  857.  
  858.     if (part2 != NULL) {
  859.     if (new) {
  860.         varPtr = NewVar(0);
  861.         Tcl_SetHashValue(hPtr, varPtr);
  862.         varPtr->flags = VAR_ARRAY;
  863.         varPtr->value.tablePtr = (Tcl_HashTable *)
  864.             ckalloc(sizeof(Tcl_HashTable));
  865.         Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  866.     } else {
  867.         if (varPtr->flags & VAR_UNDEFINED) {
  868.         varPtr->flags = VAR_ARRAY;
  869.         varPtr->value.tablePtr = (Tcl_HashTable *)
  870.             ckalloc(sizeof(Tcl_HashTable));
  871.         Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  872.         } else if (!(varPtr->flags & VAR_ARRAY)) {
  873.         iPtr->result = needArray;
  874.         return TCL_ERROR;
  875.         }
  876.     }
  877.     hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, part2, &new);
  878.     }
  879.  
  880.     if (new) {
  881.     if ((part2 != NULL) && (varPtr->searchPtr != NULL)) {
  882.         DeleteSearches(varPtr);
  883.     }
  884.     varPtr = NewVar(0);
  885.     varPtr->flags = VAR_UNDEFINED;
  886.     Tcl_SetHashValue(hPtr, varPtr);
  887.     } else {
  888.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  889.     }
  890.  
  891.     /*
  892.      * Set up trace information.
  893.      */
  894.  
  895.     tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
  896.     tracePtr->traceProc = proc;
  897.     tracePtr->clientData = clientData;
  898.     tracePtr->flags = flags &
  899.         (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS);
  900.     tracePtr->nextPtr = varPtr->tracePtr;
  901.     varPtr->tracePtr = tracePtr;
  902.     return TCL_OK;
  903. }
  904.  
  905. /*
  906.  *----------------------------------------------------------------------
  907.  *
  908.  * Tcl_UntraceVar --
  909.  *
  910.  *    Remove a previously-created trace for a variable.
  911.  *
  912.  * Results:
  913.  *    None.
  914.  *
  915.  * Side effects:
  916.  *    If there exists a trace for the variable given by varName
  917.  *    with the given flags, proc, and clientData, then that trace
  918.  *    is removed.
  919.  *
  920.  *----------------------------------------------------------------------
  921.  */
  922.  
  923. void
  924. Tcl_UntraceVar(interp, varName, flags, proc, clientData)
  925.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  926.     char *varName;        /* Name of variable;  may end with "(index)"
  927.                  * to signify an array reference. */
  928.     int flags;            /* OR-ed collection of bits describing
  929.                  * current trace, including any of
  930.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  931.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  932.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  933.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  934. {
  935.     register char *p;
  936.  
  937.     /*
  938.      * If varName refers to an array (it ends with a parenthesized
  939.      * element name), then handle it specially.
  940.      */
  941.  
  942.     for (p = varName; *p != '\0'; p++) {
  943.     if (*p == '(') {
  944.         char *open = p;
  945.  
  946.         do {
  947.         p++;
  948.         } while (*p != '\0');
  949.         p--;
  950.         if (*p != ')') {
  951.         goto scalar;
  952.         }
  953.         *open = '\0';
  954.         *p = '\0';
  955.         Tcl_UntraceVar2(interp, varName, open+1, flags, proc, clientData);
  956.         *open = '(';
  957.         *p = ')';
  958.         return;
  959.     }
  960.     }
  961.  
  962.     scalar:
  963.     Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
  964. }
  965.  
  966. /*
  967.  *----------------------------------------------------------------------
  968.  *
  969.  * Tcl_UntraceVar2 --
  970.  *
  971.  *    Remove a previously-created trace for a variable.
  972.  *
  973.  * Results:
  974.  *    None.
  975.  *
  976.  * Side effects:
  977.  *    If there exists a trace for the variable given by part1
  978.  *    and part2 with the given flags, proc, and clientData, then
  979.  *    that trace is removed.
  980.  *
  981.  *----------------------------------------------------------------------
  982.  */
  983.  
  984. void
  985. Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
  986.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  987.     char *part1;        /* Name of variable or array. */
  988.     char *part2;        /* Name of element within array;  NULL means
  989.                  * trace applies to scalar variable or array
  990.                  * as-a-whole. */
  991.     int flags;            /* OR-ed collection of bits describing
  992.                  * current trace, including any of
  993.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  994.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  995.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  996.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  997. {
  998.     register VarTrace *tracePtr;
  999.     VarTrace *prevPtr;
  1000.     Var *varPtr;
  1001.     Interp *iPtr = (Interp *) interp;
  1002.     Tcl_HashEntry *hPtr;
  1003.     ActiveVarTrace *activePtr;
  1004.  
  1005.     /*
  1006.      * First, lookup the variable.
  1007.      */
  1008.  
  1009.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  1010.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, part1);
  1011.     } else {
  1012.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, part1);
  1013.     }
  1014.     if (hPtr == NULL) {
  1015.     return;
  1016.     }
  1017.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1018.     if (varPtr->flags & VAR_UPVAR) {
  1019.     hPtr = varPtr->value.upvarPtr;
  1020.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1021.     }
  1022.     if (part2 != NULL) {
  1023.     if (!(varPtr->flags & VAR_ARRAY)) {
  1024.         return;
  1025.     }
  1026.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, part2);
  1027.     if (hPtr == NULL) {
  1028.         return;
  1029.     }
  1030.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1031.     }
  1032.  
  1033.     flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
  1034.     for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
  1035.         prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
  1036.     if (tracePtr == NULL) {
  1037.         return;
  1038.     }
  1039.     if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
  1040.         && (tracePtr->clientData == clientData)) {
  1041.         break;
  1042.     }
  1043.     }
  1044.  
  1045.     /*
  1046.      * The code below makes it possible to delete traces while traces
  1047.      * are active:  it makes sure that the deleted trace won't be
  1048.      * processed by CallTraces.
  1049.      */
  1050.  
  1051.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  1052.         activePtr = activePtr->nextPtr) {
  1053.     if (activePtr->nextTracePtr == tracePtr) {
  1054.         activePtr->nextTracePtr = tracePtr->nextPtr;
  1055.     }
  1056.     }
  1057.     if (prevPtr == NULL) {
  1058.     varPtr->tracePtr = tracePtr->nextPtr;
  1059.     } else {
  1060.     prevPtr->nextPtr = tracePtr->nextPtr;
  1061.     }
  1062.     ckfree((char *) tracePtr);
  1063. }
  1064.  
  1065. /*
  1066.  *----------------------------------------------------------------------
  1067.  *
  1068.  * Tcl_VarTraceInfo --
  1069.  *
  1070.  *    Return the clientData value associated with a trace on a
  1071.  *    variable.  This procedure can also be used to step through
  1072.  *    all of the traces on a particular variable that have the
  1073.  *    same trace procedure.
  1074.  *
  1075.  * Results:
  1076.  *    The return value is the clientData value associated with
  1077.  *    a trace on the given variable.  Information will only be
  1078.  *    returned for a trace with proc as trace procedure.  If
  1079.  *    the clientData argument is NULL then the first such trace is
  1080.  *    returned;  otherwise, the next relevant one after the one
  1081.  *    given by clientData will be returned.  If the variable
  1082.  *    doesn't exist, or if there are no (more) traces for it,
  1083.  *    then NULL is returned.
  1084.  *
  1085.  * Side effects:
  1086.  *    None.
  1087.  *
  1088.  *----------------------------------------------------------------------
  1089.  */
  1090.  
  1091. ClientData
  1092. Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
  1093.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1094.     char *varName;        /* Name of variable;  may end with "(index)"
  1095.                  * to signify an array reference. */
  1096.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1097.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1098.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1099.                  * by this procedure, so this call will
  1100.                  * return the next trace after that one.
  1101.                  * If NULL, this call will return the
  1102.                  * first trace. */
  1103. {
  1104.     register char *p;
  1105.  
  1106.     /*
  1107.      * If varName refers to an array (it ends with a parenthesized
  1108.      * element name), then handle it specially.
  1109.      */
  1110.  
  1111.     for (p = varName; *p != '\0'; p++) {
  1112.     if (*p == '(') {
  1113.         ClientData result;
  1114.         char *open = p;
  1115.  
  1116.         do {
  1117.         p++;
  1118.         } while (*p != '\0');
  1119.         p--;
  1120.         if (*p != ')') {
  1121.         goto scalar;
  1122.         }
  1123.         *open = '\0';
  1124.         *p = '\0';
  1125.         result = Tcl_VarTraceInfo2(interp, varName, open+1, flags, proc,
  1126.         prevClientData);
  1127.         *open = '(';
  1128.         *p = ')';
  1129.         return result;
  1130.     }
  1131.     }
  1132.  
  1133.     scalar:
  1134.     return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc,
  1135.         prevClientData);
  1136. }
  1137.  
  1138. /*
  1139.  *----------------------------------------------------------------------
  1140.  *
  1141.  * Tcl_VarTraceInfo2 --
  1142.  *
  1143.  *    Same as Tcl_VarTraceInfo, except takes name in two pieces
  1144.  *    instead of one.
  1145.  *
  1146.  * Results:
  1147.  *    Same as Tcl_VarTraceInfo.
  1148.  *
  1149.  * Side effects:
  1150.  *    None.
  1151.  *
  1152.  *----------------------------------------------------------------------
  1153.  */
  1154.  
  1155. ClientData
  1156. Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
  1157.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1158.     char *part1;        /* Name of variable or array. */
  1159.     char *part2;        /* Name of element within array;  NULL means
  1160.                  * trace applies to scalar variable or array
  1161.                  * as-a-whole. */
  1162.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1163.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1164.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1165.                  * by this procedure, so this call will
  1166.                  * return the next trace after that one.
  1167.                  * If NULL, this call will return the
  1168.                  * first trace. */
  1169. {
  1170.     register VarTrace *tracePtr;
  1171.     Var *varPtr;
  1172.     Interp *iPtr = (Interp *) interp;
  1173.     Tcl_HashEntry *hPtr;
  1174.  
  1175.     /*
  1176.      * First, lookup the variable.
  1177.      */
  1178.  
  1179.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  1180.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, part1);
  1181.     } else {
  1182.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, part1);
  1183.     }
  1184.     if (hPtr == NULL) {
  1185.     return NULL;
  1186.     }
  1187.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1188.     if (varPtr->flags & VAR_UPVAR) {
  1189.     hPtr = varPtr->value.upvarPtr;
  1190.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1191.     }
  1192.     if (part2 != NULL) {
  1193.     if (!(varPtr->flags & VAR_ARRAY)) {
  1194.         return NULL;
  1195.     }
  1196.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, part2);
  1197.     if (hPtr == NULL) {
  1198.         return NULL;
  1199.     }
  1200.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1201.     }
  1202.  
  1203.     /*
  1204.      * Find the relevant trace, if any, and return its clientData.
  1205.      */
  1206.  
  1207.     tracePtr = varPtr->tracePtr;
  1208.     if (prevClientData != NULL) {
  1209.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1210.         if ((tracePtr->clientData == prevClientData)
  1211.             && (tracePtr->traceProc == proc)) {
  1212.         tracePtr = tracePtr->nextPtr;
  1213.         break;
  1214.         }
  1215.     }
  1216.     }
  1217.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1218.     if (tracePtr->traceProc == proc) {
  1219.         return tracePtr->clientData;
  1220.     }
  1221.     }
  1222.     return NULL;
  1223. }
  1224.  
  1225. /*
  1226.  *----------------------------------------------------------------------
  1227.  *
  1228.  * Tcl_SetCmd --
  1229.  *
  1230.  *    This procedure is invoked to process the "set" Tcl command.
  1231.  *    See the user documentation for details on what it does.
  1232.  *
  1233.  * Results:
  1234.  *    A standard Tcl result value.
  1235.  *
  1236.  * Side effects:
  1237.  *    A variable's value may be changed.
  1238.  *
  1239.  *----------------------------------------------------------------------
  1240.  */
  1241.  
  1242.     /* ARGSUSED */
  1243. int
  1244. Tcl_SetCmd(dummy, interp, argc, argv)
  1245.     ClientData dummy;            /* Not used. */
  1246.     register Tcl_Interp *interp;    /* Current interpreter. */
  1247.     int argc;                /* Number of arguments. */
  1248.     char **argv;            /* Argument strings. */
  1249. {
  1250.     if (argc == 2) {
  1251.     char *value;
  1252.  
  1253.     value = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  1254.     if (value == NULL) {
  1255.         return TCL_ERROR;
  1256.     }
  1257.     interp->result = value;
  1258.     return TCL_OK;
  1259.     } else if (argc == 3) {
  1260.     char *result;
  1261.  
  1262.     result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG);
  1263.     if (result == NULL) {
  1264.         return TCL_ERROR;
  1265.     }
  1266.     interp->result = result;
  1267.     return TCL_OK;
  1268.     } else {
  1269.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1270.         argv[0], " varName ?newValue?\"", (char *) NULL);
  1271.     return TCL_ERROR;
  1272.     }
  1273. }
  1274.  
  1275. /*
  1276.  *----------------------------------------------------------------------
  1277.  *
  1278.  * Tcl_UnsetCmd --
  1279.  *
  1280.  *    This procedure is invoked to process the "unset" Tcl command.
  1281.  *    See the user documentation for details on what it does.
  1282.  *
  1283.  * Results:
  1284.  *    A standard Tcl result value.
  1285.  *
  1286.  * Side effects:
  1287.  *    See the user documentation.
  1288.  *
  1289.  *----------------------------------------------------------------------
  1290.  */
  1291.  
  1292.     /* ARGSUSED */
  1293. int
  1294. Tcl_UnsetCmd(dummy, interp, argc, argv)
  1295.     ClientData dummy;            /* Not used. */
  1296.     register Tcl_Interp *interp;    /* Current interpreter. */
  1297.     int argc;                /* Number of arguments. */
  1298.     char **argv;            /* Argument strings. */
  1299. {
  1300.     int i;
  1301.  
  1302.     if (argc < 2) {
  1303.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1304.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1305.     return TCL_ERROR;
  1306.     }
  1307.     for (i = 1; i < argc; i++) {
  1308.     if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != 0) {
  1309.         return TCL_ERROR;
  1310.     }
  1311.     }
  1312.     return TCL_OK;
  1313. }
  1314.  
  1315. /*
  1316.  *----------------------------------------------------------------------
  1317.  *
  1318.  * Tcl_AppendCmd --
  1319.  *
  1320.  *    This procedure is invoked to process the "append" Tcl command.
  1321.  *    See the user documentation for details on what it does.
  1322.  *
  1323.  * Results:
  1324.  *    A standard Tcl result value.
  1325.  *
  1326.  * Side effects:
  1327.  *    A variable's value may be changed.
  1328.  *
  1329.  *----------------------------------------------------------------------
  1330.  */
  1331.  
  1332.     /* ARGSUSED */
  1333. int
  1334. Tcl_AppendCmd(dummy, interp, argc, argv)
  1335.     ClientData dummy;            /* Not used. */
  1336.     register Tcl_Interp *interp;    /* Current interpreter. */
  1337.     int argc;                /* Number of arguments. */
  1338.     char **argv;            /* Argument strings. */
  1339. {
  1340.     int i;
  1341.     char *result = NULL;        /* (Initialization only needed to keep
  1342.                      * the compiler from complaining) */
  1343.  
  1344.     if (argc < 3) {
  1345.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1346.         argv[0], " varName value ?value ...?\"", (char *) NULL);
  1347.     return TCL_ERROR;
  1348.     }
  1349.  
  1350.     for (i = 2; i < argc; i++) {
  1351.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1352.         TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
  1353.     if (result == NULL) {
  1354.         return TCL_ERROR;
  1355.     }
  1356.     }
  1357.     interp->result = result;
  1358.     return TCL_OK;
  1359. }
  1360.  
  1361. /*
  1362.  *----------------------------------------------------------------------
  1363.  *
  1364.  * Tcl_LappendCmd --
  1365.  *
  1366.  *    This procedure is invoked to process the "lappend" Tcl command.
  1367.  *    See the user documentation for details on what it does.
  1368.  *
  1369.  * Results:
  1370.  *    A standard Tcl result value.
  1371.  *
  1372.  * Side effects:
  1373.  *    A variable's value may be changed.
  1374.  *
  1375.  *----------------------------------------------------------------------
  1376.  */
  1377.  
  1378.     /* ARGSUSED */
  1379. int
  1380. Tcl_LappendCmd(dummy, interp, argc, argv)
  1381.     ClientData dummy;            /* Not used. */
  1382.     register Tcl_Interp *interp;    /* Current interpreter. */
  1383.     int argc;                /* Number of arguments. */
  1384.     char **argv;            /* Argument strings. */
  1385. {
  1386.     int i;
  1387.     char *result = NULL;        /* (Initialization only needed to keep
  1388.                      * the compiler from complaining) */
  1389.  
  1390.     if (argc < 3) {
  1391.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1392.         argv[0], " varName value ?value ...?\"", (char *) NULL);
  1393.     return TCL_ERROR;
  1394.     }
  1395.  
  1396.     for (i = 2; i < argc; i++) {
  1397.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1398.         TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG);
  1399.     if (result == NULL) {
  1400.         return TCL_ERROR;
  1401.     }
  1402.     }
  1403.     interp->result = result;
  1404.     return TCL_OK;
  1405. }
  1406.  
  1407. /*
  1408.  *----------------------------------------------------------------------
  1409.  *
  1410.  * Tcl_ArrayCmd --
  1411.  *
  1412.  *    This procedure is invoked to process the "array" Tcl command.
  1413.  *    See the user documentation for details on what it does.
  1414.  *
  1415.  * Results:
  1416.  *    A standard Tcl result value.
  1417.  *
  1418.  * Side effects:
  1419.  *    See the user documentation.
  1420.  *
  1421.  *----------------------------------------------------------------------
  1422.  */
  1423.  
  1424.     /* ARGSUSED */
  1425. int
  1426. Tcl_ArrayCmd(dummy, interp, argc, argv)
  1427.     ClientData dummy;            /* Not used. */
  1428.     register Tcl_Interp *interp;    /* Current interpreter. */
  1429.     int argc;                /* Number of arguments. */
  1430.     char **argv;            /* Argument strings. */
  1431. {
  1432.     int length;
  1433.     char c;
  1434.     Var *varPtr;
  1435.     Tcl_HashEntry *hPtr;
  1436.     Interp *iPtr = (Interp *) interp;
  1437.  
  1438.     if (argc < 3) {
  1439.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1440.         argv[0], " option arrayName ?arg ...?\"", (char *) NULL);
  1441.     return TCL_ERROR;
  1442.     }
  1443.  
  1444.     /*
  1445.      * Locate the array variable (and it better be an array).
  1446.      */
  1447.  
  1448.     if (iPtr->varFramePtr == NULL) {
  1449.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  1450.     } else {
  1451.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  1452.     }
  1453.     if (hPtr == NULL) {
  1454.     notArray:
  1455.     Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
  1456.         (char *) NULL);
  1457.     return TCL_ERROR;
  1458.     }
  1459.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1460.     if (varPtr->flags & VAR_UPVAR) {
  1461.     varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
  1462.     }
  1463.     if (!(varPtr->flags & VAR_ARRAY)) {
  1464.     goto notArray;
  1465.     }
  1466.  
  1467.     /*
  1468.      * Dispatch based on the option.
  1469.      */
  1470.  
  1471.     c = argv[1][0];
  1472.     length = strlen(argv[1]);
  1473.     if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
  1474.     ArraySearch *searchPtr;
  1475.  
  1476.     if (argc != 4) {
  1477.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1478.             argv[0], " anymore arrayName searchId\"", (char *) NULL);
  1479.         return TCL_ERROR;
  1480.     }
  1481.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1482.     if (searchPtr == NULL) {
  1483.         return TCL_ERROR;
  1484.     }
  1485.     while (1) {
  1486.         Var *varPtr2;
  1487.  
  1488.         if (searchPtr->nextEntry != NULL) {
  1489.         varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
  1490.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1491.             break;
  1492.         }
  1493.         }
  1494.         searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
  1495.         if (searchPtr->nextEntry == NULL) {
  1496.         interp->result = "0";
  1497.         return TCL_OK;
  1498.         }
  1499.     }
  1500.     interp->result = "1";
  1501.     return TCL_OK;
  1502.     } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
  1503.     ArraySearch *searchPtr, *prevPtr;
  1504.  
  1505.     if (argc != 4) {
  1506.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1507.             argv[0], " donesearch arrayName searchId\"", (char *) NULL);
  1508.         return TCL_ERROR;
  1509.     }
  1510.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1511.     if (searchPtr == NULL) {
  1512.         return TCL_ERROR;
  1513.     }
  1514.     if (varPtr->searchPtr == searchPtr) {
  1515.         varPtr->searchPtr = searchPtr->nextPtr;
  1516.     } else {
  1517.         for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
  1518.         if (prevPtr->nextPtr == searchPtr) {
  1519.             prevPtr->nextPtr = searchPtr->nextPtr;
  1520.             break;
  1521.         }
  1522.         }
  1523.     }
  1524.     ckfree((char *) searchPtr);
  1525.     } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)
  1526.         && (length >= 2)) {
  1527.     Tcl_HashSearch search;
  1528.     Var *varPtr2;
  1529.  
  1530.     if (argc != 3) {
  1531.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1532.             argv[0], " names arrayName\"", (char *) NULL);
  1533.         return TCL_ERROR;
  1534.     }
  1535.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1536.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1537.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1538.         if (varPtr2->flags & VAR_UNDEFINED) {
  1539.         continue;
  1540.         }
  1541.         Tcl_AppendElement(interp,
  1542.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), 0);
  1543.     }
  1544.     } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)
  1545.         && (length >= 2)) {
  1546.     ArraySearch *searchPtr;
  1547.     Tcl_HashEntry *hPtr;
  1548.  
  1549.     if (argc != 4) {
  1550.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1551.             argv[0], " nextelement arrayName searchId\"",
  1552.             (char *) NULL);
  1553.         return TCL_ERROR;
  1554.     }
  1555.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1556.     if (searchPtr == NULL) {
  1557.         return TCL_ERROR;
  1558.     }
  1559.     while (1) {
  1560.         Var *varPtr2;
  1561.  
  1562.         hPtr = searchPtr->nextEntry;
  1563.         if (hPtr == NULL) {
  1564.         hPtr = Tcl_NextHashEntry(&searchPtr->search);
  1565.         if (hPtr == NULL) {
  1566.             return TCL_OK;
  1567.         }
  1568.         } else {
  1569.         searchPtr->nextEntry = NULL;
  1570.         }
  1571.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1572.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1573.         break;
  1574.         }
  1575.     }
  1576.     interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1577.     } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  1578.         && (length >= 2)) {
  1579.     Tcl_HashSearch search;
  1580.     Var *varPtr2;
  1581.     int size;
  1582.  
  1583.     if (argc != 3) {
  1584.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1585.             argv[0], " size arrayName\"", (char *) NULL);
  1586.         return TCL_ERROR;
  1587.     }
  1588.     size = 0;
  1589.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1590.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1591.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1592.         if (varPtr2->flags & VAR_UNDEFINED) {
  1593.         continue;
  1594.         }
  1595.         size++;
  1596.     }
  1597.     sprintf(interp->result, "%d", size);
  1598.     } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)
  1599.         && (length >= 2)) {
  1600.     ArraySearch *searchPtr;
  1601.  
  1602.     if (argc != 3) {
  1603.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1604.             argv[0], " startsearch arrayName\"", (char *) NULL);
  1605.         return TCL_ERROR;
  1606.     }
  1607.     searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
  1608.     if (varPtr->searchPtr == NULL) {
  1609.         searchPtr->id = 1;
  1610.         Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
  1611.     } else {
  1612.         char string[20];
  1613.  
  1614.         searchPtr->id = varPtr->searchPtr->id + 1;
  1615.         sprintf(string, "%d", searchPtr->id);
  1616.         Tcl_AppendResult(interp, "s-", string, "-", argv[2],
  1617.             (char *) NULL);
  1618.     }
  1619.     searchPtr->varPtr = varPtr;
  1620.     searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
  1621.         &searchPtr->search);
  1622.     searchPtr->nextPtr = varPtr->searchPtr;
  1623.     varPtr->searchPtr = searchPtr;
  1624.     } else {
  1625.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1626.         "\": should be anymore, donesearch, names, nextelement, ",
  1627.         "size, or startsearch", (char *) NULL);
  1628.     return TCL_ERROR;
  1629.     }
  1630.     return TCL_OK;
  1631. }
  1632.  
  1633. /*
  1634.  *----------------------------------------------------------------------
  1635.  *
  1636.  * Tcl_GlobalCmd --
  1637.  *
  1638.  *    This procedure is invoked to process the "global" Tcl command.
  1639.  *    See the user documentation for details on what it does.
  1640.  *
  1641.  * Results:
  1642.  *    A standard Tcl result value.
  1643.  *
  1644.  * Side effects:
  1645.  *    See the user documentation.
  1646.  *
  1647.  *----------------------------------------------------------------------
  1648.  */
  1649.  
  1650.     /* ARGSUSED */
  1651. int
  1652. Tcl_GlobalCmd(dummy, interp, argc, argv)
  1653.     ClientData dummy;            /* Not used. */
  1654.     Tcl_Interp *interp;            /* Current interpreter. */
  1655.     int argc;                /* Number of arguments. */
  1656.     char **argv;            /* Argument strings. */
  1657. {
  1658.     Var *varPtr, *gVarPtr;
  1659.     register Interp *iPtr = (Interp *) interp;
  1660.     Tcl_HashEntry *hPtr, *hPtr2;
  1661.     int new;
  1662.  
  1663.     if (argc < 2) {
  1664.     Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
  1665.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1666.     return TCL_ERROR;
  1667.     }
  1668.     if (iPtr->varFramePtr == NULL) {
  1669.     return TCL_OK;
  1670.     }
  1671.  
  1672.     for (argc--, argv++; argc > 0; argc--, argv++) {
  1673.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, *argv, &new);
  1674.     if (new) {
  1675.         gVarPtr = NewVar(0);
  1676.         gVarPtr->flags |= VAR_UNDEFINED;
  1677.         Tcl_SetHashValue(hPtr, gVarPtr);
  1678.     } else {
  1679.         gVarPtr = (Var *) Tcl_GetHashValue(hPtr);
  1680.     }
  1681.     hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, *argv, &new);
  1682.     if (!new) {
  1683.         Var *varPtr;
  1684.         varPtr = (Var *) Tcl_GetHashValue(hPtr2);
  1685.         if (varPtr->flags & VAR_UPVAR) {
  1686.         continue;
  1687.         } else {
  1688.         Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", *argv,
  1689.             "\" already exists", (char *) NULL);
  1690.         return TCL_ERROR;
  1691.         }
  1692.     }
  1693.     varPtr = NewVar(0);
  1694.     varPtr->flags |= VAR_UPVAR;
  1695.     varPtr->value.upvarPtr = hPtr;
  1696.     gVarPtr->upvarUses++;
  1697.     Tcl_SetHashValue(hPtr2, varPtr);
  1698.     }
  1699.     return TCL_OK;
  1700. }
  1701.  
  1702. /*
  1703.  *----------------------------------------------------------------------
  1704.  *
  1705.  * Tcl_UpvarCmd --
  1706.  *
  1707.  *    This procedure is invoked to process the "upvar" Tcl command.
  1708.  *    See the user documentation for details on what it does.
  1709.  *
  1710.  * Results:
  1711.  *    A standard Tcl result value.
  1712.  *
  1713.  * Side effects:
  1714.  *    See the user documentation.
  1715.  *
  1716.  *----------------------------------------------------------------------
  1717.  */
  1718.  
  1719.     /* ARGSUSED */
  1720. int
  1721. Tcl_UpvarCmd(dummy, interp, argc, argv)
  1722.     ClientData dummy;            /* Not used. */
  1723.     Tcl_Interp *interp;            /* Current interpreter. */
  1724.     int argc;                /* Number of arguments. */
  1725.     char **argv;            /* Argument strings. */
  1726. {
  1727.     register Interp *iPtr = (Interp *) interp;
  1728.     int result;
  1729.     CallFrame *framePtr;
  1730.     Var *varPtr = NULL;
  1731.     Tcl_HashTable *upVarTablePtr;
  1732.     Tcl_HashEntry *hPtr, *hPtr2;
  1733.     int new;
  1734.     Var *upVarPtr;
  1735.  
  1736.     if (argc < 3) {
  1737.     upvarSyntax:
  1738.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1739.         " ?level? otherVar localVar ?otherVar localVar ...?\"",
  1740.         (char *) NULL);
  1741.     return TCL_ERROR;
  1742.     }
  1743.  
  1744.     /*
  1745.      * Find the hash table containing the variable being referenced.
  1746.      */
  1747.  
  1748.     result = TclGetFrame(interp, argv[1], &framePtr);
  1749.     if (result == -1) {
  1750.     return TCL_ERROR;
  1751.     }
  1752.     argc -= result+1;
  1753.     argv += result+1;
  1754.     if (framePtr == NULL) {
  1755.     upVarTablePtr = &iPtr->globalTable;
  1756.     } else {
  1757.     upVarTablePtr = &framePtr->varTable;
  1758.     }
  1759.  
  1760.     if ((argc & 1) != 0) {
  1761.     goto upvarSyntax;
  1762.     }
  1763.  
  1764.     /*
  1765.      * Iterate over all the pairs of (local variable, other variable)
  1766.      * names.  For each pair, create a hash table entry in the upper
  1767.      * context (if the name wasn't there already), then associate it
  1768.      * with a new local variable.
  1769.      */
  1770.  
  1771.     while (argc > 0) {
  1772.         hPtr = Tcl_CreateHashEntry(upVarTablePtr, argv[0], &new);
  1773.         if (new) {
  1774.             upVarPtr = NewVar(0);
  1775.             upVarPtr->flags |= VAR_UNDEFINED;
  1776.             Tcl_SetHashValue(hPtr, upVarPtr);
  1777.         } else {
  1778.             upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
  1779.         if (upVarPtr->flags & VAR_UPVAR) {
  1780.         hPtr = upVarPtr->value.upvarPtr;
  1781.         upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
  1782.         }
  1783.         }
  1784.  
  1785.         hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
  1786.                     argv[1], &new);
  1787.         if (!new) {
  1788.             Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", argv[1],
  1789.                 "\" already exists", (char *) NULL);
  1790.             return TCL_ERROR;
  1791.         }
  1792.         varPtr = NewVar(0);
  1793.         varPtr->flags |= VAR_UPVAR;
  1794.         varPtr->value.upvarPtr = hPtr;
  1795.         upVarPtr->upvarUses++;
  1796.         Tcl_SetHashValue(hPtr2, varPtr);
  1797.  
  1798.         argc -= 2;
  1799.         argv += 2;
  1800.     }
  1801.     return TCL_OK;
  1802. }
  1803.  
  1804. /*
  1805.  *----------------------------------------------------------------------
  1806.  *
  1807.  * TclDeleteVars --
  1808.  *
  1809.  *    This procedure is called to recycle all the storage space
  1810.  *    associated with a table of variables.  For this procedure
  1811.  *    to work correctly, it must not be possible for any of the
  1812.  *    variable in the table to be accessed from Tcl commands
  1813.  *    (e.g. from trace procedures).
  1814.  *
  1815.  * Results:
  1816.  *    None.
  1817.  *
  1818.  * Side effects:
  1819.  *    Variables are deleted and trace procedures are invoked, if
  1820.  *    any are declared.
  1821.  *
  1822.  *----------------------------------------------------------------------
  1823.  */
  1824.  
  1825. void
  1826. TclDeleteVars(iPtr, tablePtr)
  1827.     Interp *iPtr;        /* Interpreter to which variables belong. */
  1828.     Tcl_HashTable *tablePtr;    /* Hash table containing variables to
  1829.                  * delete. */
  1830. {
  1831.     Tcl_HashSearch search;
  1832.     Tcl_HashEntry *hPtr;
  1833.     register Var *varPtr;
  1834.     int flags, globalFlag;
  1835.  
  1836.     flags = TCL_TRACE_UNSETS;
  1837.     if (tablePtr == &iPtr->globalTable) {
  1838.     flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY;
  1839.     }
  1840.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
  1841.         hPtr = Tcl_NextHashEntry(&search)) {
  1842.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1843.  
  1844.     /*
  1845.      * For global/upvar variables referenced in procedures, free up the
  1846.      * local space and then decrement the reference count on the
  1847.      * variable referred to.  If there are no more references to the
  1848.      * global/upvar and it is undefined and has no traces set, then
  1849.      * follow on and delete the referenced variable too.
  1850.      */
  1851.  
  1852.     globalFlag = 0;
  1853.     if (varPtr->flags & VAR_UPVAR) {
  1854.         hPtr = varPtr->value.upvarPtr;
  1855.         ckfree((char *) varPtr);
  1856.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1857.         varPtr->upvarUses--;
  1858.         if ((varPtr->upvarUses != 0) || !(varPtr->flags & VAR_UNDEFINED)
  1859.             || (varPtr->tracePtr != NULL)) {
  1860.         continue;
  1861.         }
  1862.         globalFlag = TCL_GLOBAL_ONLY;
  1863.     }
  1864.  
  1865.     /*
  1866.      * Invoke traces on the variable that is being deleted, then
  1867.      * free up the variable's space (no need to free the hash entry
  1868.      * here, unless we're dealing with a global variable:  the
  1869.      * hash entries will be deleted automatically when the whole
  1870.      * table is deleted).
  1871.      */
  1872.  
  1873.     if (varPtr->tracePtr != NULL) {
  1874.         (void) CallTraces(iPtr, (Var *) NULL, hPtr,
  1875.             Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL,
  1876.             flags | globalFlag);
  1877.         while (varPtr->tracePtr != NULL) {
  1878.         VarTrace *tracePtr = varPtr->tracePtr;
  1879.         varPtr->tracePtr = tracePtr->nextPtr;
  1880.         ckfree((char *) tracePtr);
  1881.         }
  1882.     }
  1883.     if (varPtr->flags & VAR_ARRAY) {
  1884.         DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr,
  1885.             flags | globalFlag);
  1886.     }
  1887.     if (globalFlag) {
  1888.         Tcl_DeleteHashEntry(hPtr);
  1889.     }
  1890.     ckfree((char *) varPtr);
  1891.     }
  1892.     Tcl_DeleteHashTable(tablePtr);
  1893. }
  1894.  
  1895. /*
  1896.  *----------------------------------------------------------------------
  1897.  *
  1898.  * CallTraces --
  1899.  *
  1900.  *    This procedure is invoked to find and invoke relevant
  1901.  *    trace procedures associated with a particular operation on
  1902.  *    a variable.  This procedure invokes traces both on the
  1903.  *    variable and on its containing array (where relevant).
  1904.  *
  1905.  * Results:
  1906.  *    The return value is NULL if no trace procedures were invoked, or
  1907.  *    if all the invoked trace procedures returned successfully.
  1908.  *    The return value is non-zero if a trace procedure returned an
  1909.  *    error (in this case no more trace procedures were invoked after
  1910.  *    the error was returned).  In this case the return value is a
  1911.  *    pointer to a static string describing the error.
  1912.  *
  1913.  * Side effects:
  1914.  *    Almost anything can happen, depending on trace;  this procedure
  1915.  *    itself doesn't have any side effects.
  1916.  *
  1917.  *----------------------------------------------------------------------
  1918.  */
  1919.  
  1920. static char *
  1921. CallTraces(iPtr, arrayPtr, hPtr, part1, part2, flags)
  1922.     Interp *iPtr;            /* Interpreter containing variable. */
  1923.     register Var *arrayPtr;        /* Pointer to array variable that
  1924.                      * contains the variable, or NULL if
  1925.                      * the variable isn't an element of an
  1926.                      * array. */
  1927.     Tcl_HashEntry *hPtr;        /* Hash table entry corresponding to
  1928.                      * variable whose traces are to be
  1929.                      * invoked. */
  1930.     char *part1, *part2;        /* Variable's two-part name. */
  1931.     int flags;                /* Flags to pass to trace procedures:
  1932.                      * indicates what's happening to
  1933.                      * variable, plus other stuff like
  1934.                      * TCL_GLOBAL_ONLY and
  1935.                      * TCL_INTERP_DESTROYED. */
  1936. {
  1937.     Var *varPtr;
  1938.     register VarTrace *tracePtr;
  1939.     ActiveVarTrace active;
  1940.     char *result;
  1941.     int savedArrayFlags = 0;        /* (Initialization not needed except
  1942.                      * to prevent compiler warning) */
  1943.  
  1944.     /*
  1945.      * If there are already similar trace procedures active for the
  1946.      * variable, don't call them again.
  1947.      */
  1948.  
  1949.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1950.     if (varPtr->flags & VAR_TRACE_ACTIVE) {
  1951.     return NULL;
  1952.     }
  1953.     varPtr->flags |= VAR_TRACE_ACTIVE;
  1954.  
  1955.     /*
  1956.      * Invoke traces on the array containing the variable, if relevant.
  1957.      */
  1958.  
  1959.     result = NULL;
  1960.     active.nextPtr = iPtr->activeTracePtr;
  1961.     iPtr->activeTracePtr = &active;
  1962.     if (arrayPtr != NULL) {
  1963.     savedArrayFlags = arrayPtr->flags;
  1964.     arrayPtr->flags |= VAR_ELEMENT_ACTIVE;
  1965.     for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
  1966.         tracePtr = active.nextTracePtr) {
  1967.         active.nextTracePtr = tracePtr->nextPtr;
  1968.         if (!(tracePtr->flags & flags)) {
  1969.         continue;
  1970.         }
  1971.         result = (*tracePtr->traceProc)(tracePtr->clientData,
  1972.             (Tcl_Interp *) iPtr, part1, part2, flags);
  1973.         if (result != NULL) {
  1974.         if (flags & TCL_TRACE_UNSETS) {
  1975.             result = NULL;
  1976.         } else {
  1977.             goto done;
  1978.         }
  1979.         }
  1980.     }
  1981.     }
  1982.  
  1983.     /*
  1984.      * Invoke traces on the variable itself.
  1985.      */
  1986.  
  1987.     if (flags & TCL_TRACE_UNSETS) {
  1988.     flags |= TCL_TRACE_DESTROYED;
  1989.     }
  1990.     for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
  1991.         tracePtr = active.nextTracePtr) {
  1992.     active.nextTracePtr = tracePtr->nextPtr;
  1993.     if (!(tracePtr->flags & flags)) {
  1994.         continue;
  1995.     }
  1996.     result = (*tracePtr->traceProc)(tracePtr->clientData,
  1997.         (Tcl_Interp *) iPtr, part1, part2, flags);
  1998.     if (result != NULL) {
  1999.         if (flags & TCL_TRACE_UNSETS) {
  2000.         result = NULL;
  2001.         } else {
  2002.         goto done;
  2003.         }
  2004.     }
  2005.     }
  2006.  
  2007.     /*
  2008.      * Restore the variable's flags, remove the record of our active
  2009.      * traces, and then return.  Remember that the variable could have
  2010.      * been re-allocated during the traces, but its hash entry won't
  2011.      * change.
  2012.      */
  2013.  
  2014.     done:
  2015.     if (arrayPtr != NULL) {
  2016.     arrayPtr->flags = savedArrayFlags;
  2017.     }
  2018.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  2019.     varPtr->flags &= ~VAR_TRACE_ACTIVE;
  2020.     iPtr->activeTracePtr = active.nextPtr;
  2021.     return result;
  2022. }
  2023.  
  2024. /*
  2025.  *----------------------------------------------------------------------
  2026.  *
  2027.  * NewVar --
  2028.  *
  2029.  *    Create a new variable with a given initial value.
  2030.  *
  2031.  * Results:
  2032.  *    The return value is a pointer to the new variable structure.
  2033.  *    The variable will not be part of any hash table yet, and its
  2034.  *    upvarUses count is initialized to 0.  Its initial value will
  2035.  *    be empty, but "space" bytes will be available in the value
  2036.  *    area.
  2037.  *
  2038.  * Side effects:
  2039.  *    Storage gets allocated.
  2040.  *
  2041.  *----------------------------------------------------------------------
  2042.  */
  2043.  
  2044. static Var *
  2045. NewVar(space)
  2046.     int space;        /* Minimum amount of space to allocate
  2047.              * for variable's value. */
  2048. {
  2049.     int extra;
  2050.     register Var *varPtr;
  2051.  
  2052.     extra = space - sizeof(varPtr->value);
  2053.     if (extra < 0) {
  2054.     extra = 0;
  2055.     space = sizeof(varPtr->value);
  2056.     }
  2057.     varPtr = (Var *) ckalloc((unsigned) (sizeof(Var) + extra));
  2058.     varPtr->valueLength = 0;
  2059.     varPtr->valueSpace = space;
  2060.     varPtr->upvarUses = 0;
  2061.     varPtr->tracePtr = NULL;
  2062.     varPtr->searchPtr = NULL;
  2063.     varPtr->flags = 0;
  2064.     varPtr->value.string[0] = 0;
  2065.     return varPtr;
  2066. }
  2067.  
  2068. /*
  2069.  *----------------------------------------------------------------------
  2070.  *
  2071.  * ParseSearchId --
  2072.  *
  2073.  *    This procedure translates from a string to a pointer to an
  2074.  *    active array search (if there is one that matches the string).
  2075.  *
  2076.  * Results:
  2077.  *    The return value is a pointer to the array search indicated
  2078.  *    by string, or NULL if there isn't one.  If NULL is returned,
  2079.  *    interp->result contains an error message.
  2080.  *
  2081.  * Side effects:
  2082.  *    None.
  2083.  *
  2084.  *----------------------------------------------------------------------
  2085.  */
  2086.  
  2087. static ArraySearch *
  2088. ParseSearchId(interp, varPtr, varName, string)
  2089.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  2090.     Var *varPtr;        /* Array variable search is for. */
  2091.     char *varName;        /* Name of array variable that search is
  2092.                  * supposed to be for. */
  2093.     char *string;        /* String containing id of search.  Must have
  2094.                  * form "search-num-var" where "num" is a
  2095.                  * decimal number and "var" is a variable
  2096.                  * name. */
  2097. {
  2098.     char *end;
  2099.     int id;
  2100.     ArraySearch *searchPtr;
  2101.  
  2102.     /*
  2103.      * Parse the id into the three parts separated by dashes.
  2104.      */
  2105.  
  2106.     if ((string[0] != 's') || (string[1] != '-')) {
  2107.     syntax:
  2108.     Tcl_AppendResult(interp, "illegal search identifier \"", string,
  2109.         "\"", (char *) NULL);
  2110.     return NULL;
  2111.     }
  2112.     id = strtoul(string+2, &end, 10);
  2113.     if ((end == (string+2)) || (*end != '-')) {
  2114.     goto syntax;
  2115.     }
  2116.     if (strcmp(end+1, varName) != 0) {
  2117.     Tcl_AppendResult(interp, "search identifier \"", string,
  2118.         "\" isn't for variable \"", varName, "\"", (char *) NULL);
  2119.     return NULL;
  2120.     }
  2121.  
  2122.     /*
  2123.      * Search through the list of active searches on the interpreter
  2124.      * to see if the desired one exists.
  2125.      */
  2126.  
  2127.     for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
  2128.         searchPtr = searchPtr->nextPtr) {
  2129.     if (searchPtr->id == id) {
  2130.         return searchPtr;
  2131.     }
  2132.     }
  2133.     Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
  2134.         (char *) NULL);
  2135.     return NULL;
  2136. }
  2137.  
  2138. /*
  2139.  *----------------------------------------------------------------------
  2140.  *
  2141.  * DeleteSearches --
  2142.  *
  2143.  *    This procedure is called to free up all of the searches
  2144.  *    associated with an array variable.
  2145.  *
  2146.  * Results:
  2147.  *    None.
  2148.  *
  2149.  * Side effects:
  2150.  *    Memory is released to the storage allocator.
  2151.  *
  2152.  *----------------------------------------------------------------------
  2153.  */
  2154.  
  2155. static void
  2156. DeleteSearches(arrayVarPtr)
  2157.     register Var *arrayVarPtr;        /* Variable whose searches are
  2158.                      * to be deleted. */
  2159. {
  2160.     ArraySearch *searchPtr;
  2161.  
  2162.     while (arrayVarPtr->searchPtr != NULL) {
  2163.     searchPtr = arrayVarPtr->searchPtr;
  2164.     arrayVarPtr->searchPtr = searchPtr->nextPtr;
  2165.     ckfree((char *) searchPtr);
  2166.     }
  2167. }
  2168.  
  2169. /*
  2170.  *----------------------------------------------------------------------
  2171.  *
  2172.  * DeleteArray --
  2173.  *
  2174.  *    This procedure is called to free up everything in an array
  2175.  *    variable.  It's the caller's responsibility to make sure
  2176.  *    that the array is no longer accessible before this procedure
  2177.  *    is called.
  2178.  *
  2179.  * Results:
  2180.  *    None.
  2181.  *
  2182.  * Side effects:
  2183.  *    All storage associated with varPtr's array elements is deleted
  2184.  *    (including the hash table).  Any delete trace procedures for
  2185.  *    array elements are invoked.
  2186.  *
  2187.  *----------------------------------------------------------------------
  2188.  */
  2189.  
  2190. static void
  2191. DeleteArray(iPtr, arrayName, varPtr, flags)
  2192.     Interp *iPtr;            /* Interpreter containing array. */
  2193.     char *arrayName;            /* Name of array (used for trace
  2194.                      * callbacks). */
  2195.     Var *varPtr;            /* Pointer to variable structure. */
  2196.     int flags;                /* Flags to pass to CallTraces:
  2197.                      * TCL_TRACE_UNSETS and sometimes
  2198.                      * TCL_INTERP_DESTROYED and/or
  2199.                      * TCL_GLOBAL_ONLY. */
  2200. {
  2201.     Tcl_HashSearch search;
  2202.     register Tcl_HashEntry *hPtr;
  2203.     register Var *elPtr;
  2204.  
  2205.     DeleteSearches(varPtr);
  2206.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  2207.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  2208.     elPtr = (Var *) Tcl_GetHashValue(hPtr);
  2209.     if (elPtr->tracePtr != NULL) {
  2210.         (void) CallTraces(iPtr, (Var *) NULL, hPtr, arrayName,
  2211.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
  2212.         while (elPtr->tracePtr != NULL) {
  2213.         VarTrace *tracePtr = elPtr->tracePtr;
  2214.         elPtr->tracePtr = tracePtr->nextPtr;
  2215.         ckfree((char *) tracePtr);
  2216.         }
  2217.     }
  2218.     if (elPtr->flags & VAR_SEARCHES_POSSIBLE) {
  2219.         panic("DeleteArray found searches on array alement!");
  2220.     }
  2221.     ckfree((char *) elPtr);
  2222.     }
  2223.     Tcl_DeleteHashTable(varPtr->value.tablePtr);
  2224.     ckfree((char *) varPtr->value.tablePtr);
  2225. }
  2226.  
  2227. /*
  2228.  *----------------------------------------------------------------------
  2229.  *
  2230.  * VarErrMsg --
  2231.  *
  2232.  *    Generate a reasonable error message describing why a variable
  2233.  *    operation failed.
  2234.  *
  2235.  * Results:
  2236.  *    None.
  2237.  *
  2238.  * Side effects:
  2239.  *    Interp->result is reset to hold a message identifying the
  2240.  *    variable given by part1 and part2 and describing why the
  2241.  *    variable operation failed.
  2242.  *
  2243.  *----------------------------------------------------------------------
  2244.  */
  2245.  
  2246. static void
  2247. VarErrMsg(interp, part1, part2, operation, reason)
  2248.     Tcl_Interp *interp;        /* Interpreter in which to record message. */
  2249.     char *part1, *part2;    /* Variable's two-part name. */
  2250.     char *operation;        /* String describing operation that failed,
  2251.                  * e.g. "read", "set", or "unset". */
  2252.     char *reason;        /* String describing why operation failed. */
  2253. {
  2254.     Tcl_ResetResult(interp);
  2255.     Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL);
  2256.     if (part2 != NULL) {
  2257.     Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
  2258.     }
  2259.     Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
  2260. }
  2261.